home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DIALOGS
/
JANUSW
/
VBXINFO.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1994-11-14
|
24KB
|
806 lines
{ Program: VbxInfo
Version: 1.00
Purpose: program to extract information from VBX files
Uses: BIVBX10.DLL from the BC4 package
Developer: Peter Sawatzki (ps)
Buchenhof 3, D58091 Hagen, Germany
CompuServe: 100031,3002
Date: Author:
02/26/94 ps written
Copyright (c) 1994 Peter Sawatzki. All Rights Reserved.
}
Program VbxInfo;
Uses
WinTypes,
WinProcs,
Strings,
Objects,
oWindows,
oDialogs,
oMemory,
CommDlg,
{$IfDef Debug} Debug, {$EndIf}
Vbx;
Const
VBXvalidation: tVbxValidation = cVbxValidation;
{-the collection part}
Type
pPrefixEntry = ^tPrefixEntry;
tPrefixEntry = Record
ThePrefix,
TheSource: pChar
End;
pPrefixCollection = ^tPrefixCollection;
tPrefixCollection = Object(tSortedCollection)
Function KeyOf(Item: Pointer): Pointer; Virtual;
Function Compare(Key1, Key2: Pointer): Integer; Virtual;
Procedure FreeItem(Item: Pointer); Virtual;
Function GenerateNewPrefix (SrcName: pChar): pChar;
Function MakePrefix (NewPrefix: pChar; SrcName: pChar): Boolean;
End;
Var
Prefix: pPrefixCollection;
Function tPrefixCollection.KeyOf(Item: Pointer): Pointer;
Begin
KeyOf:= pPrefixEntry(Item)^.TheSource
End;
Function tPrefixCollection.Compare(Key1, Key2: Pointer): Integer;
Begin
Compare:= StrIComp(Key1, Key2)
End;
Procedure tPrefixCollection.FreeItem(Item: Pointer);
Begin
StrDispose(pPrefixEntry(Item)^.ThePrefix);
StrDispose(pPrefixEntry(Item)^.TheSource);
Dispose(pPrefixEntry(Item))
End;
Function tPrefixCollection.GenerateNewPrefix (SrcName: pChar): pChar;
Var
np: Array[0..100] Of Char;
p,dp: pChar;
Function HasThisPrefix (Item: pPrefixEntry): Boolean; Far;
Begin
HasThisPrefix:= StrIComp(Item^.ThePrefix, np)=0
End;
Begin
np[0]:= #0;
p:= SrcName; dp:= np;
While p[0]<>#0 Do Begin
If p[0] In ['A'..'Z'] Then Begin
dp[0]:= Char(Ord(p[0])+Ord('a')-Ord('A'));
Inc(dp); dp[0]:= #0;
End;
Inc(p)
End;
If StrLen(np)=0 Then
StrCopy(np, 'enum');
If FirstThat(@HasThisPrefix)<>Nil Then Begin
dp[0]:= '1'; dp[1]:= #0;
While FirstThat(@HasThisPrefix)<>Nil Do
Inc(dp[0])
End;
GenerateNewPrefix:= StrNew(np)
End;
Function tPrefixCollection.MakePrefix (NewPrefix: pChar; SrcName: pChar): Boolean;
Var
Index: Integer;
anEntry: pPrefixEntry;
Begin
MakePrefix:= False;
If Search(SrcName, Index) Then {old prefix}
With pPrefixEntry(At(Index))^ Do
StrCopy(NewPrefix, ThePrefix)
Else Begin
anEntry:= New(pPrefixEntry);
anEntry^.TheSource:= StrNew(SrcName);
anEntry^.ThePrefix:= GenerateNewPrefix(SrcName);
Insert(anEntry);
StrCopy(NewPrefix, anEntry^.ThePrefix);
MakePrefix:= True
End
End;
Const
cm_ConvertOne = $100;
cm_ConvertSpecial = $101;
Type
pInfoWindow = ^tInfoWindow;
tInfoWindow = Object(tWindow)
Constructor Init (aParent: pWindowsObject; aTitle: pChar);
Procedure SetupWindow; Virtual;
Function GetFileName (aFn: pChar): pChar;
Function GetPascalFileName (aFn: pChar): pChar;
Procedure cmConvertOne (Var Msg: tMessage); Virtual cm_First+cm_ConvertOne;
Procedure cmConvertSpecial (Var Msg: tMessage); Virtual cm_First+cm_ConvertSpecial;
Function GenerateInfo (aVBXName, aPascalname: pChar): Boolean;
End;
Constructor tInfoWindow.Init (aParent: pWindowsObject; aTitle: pChar);
Begin
Inherited Init(aParent, aTitle);
Attr.Menu:= CreateMenu;
AppendMenu(Attr.Menu, mf_String, cm_ConvertOne, 'Convert!');
AppendMenu(Attr.Menu, mf_String, cm_ConvertSpecial, '(special)');
End;
Procedure tInfoWindow.SetupWindow;
Begin
Inherited SetupWindow;
{PostMessage(hWindow, wm_Command, cm_ConvertOne, 0)}
End;
Function tInfoWindow.GetFileName (aFn: pChar): pChar;
Var
OpenFN : tOpenFileName;
Filter : Array[0..100] Of Char;
StartDir,
FName,
FullFileName: Array[0..100] Of Char;
Begin
GetFileName:= aFn;
StrCopy(FullFileName, '');
GetWindowsDirectory(StartDir, SizeOf(StartDir));
StrCat(StartDir, '\system');
FillChar(Filter, SizeOf(Filter), #0); { Set up for double null at end }
StrCopy(Filter, 'VBX files (*.VBX)');
StrCopy(@Filter[StrLen(Filter)+1], '*.VBX');
FillChar(OpenFN, SizeOf(TOpenFileName), #0);
With OpenFN Do Begin
hInstance := System.hInstance;
hwndOwner := hWindow;
lpstrDefExt := 'VBX';
lpstrTitle := 'Load VBX file';
lpstrFile := FullFileName;
lpstrFilter := Filter;
lpstrFileTitle:= FName;
lpstrInitialDir:= StartDir;
flags := ofn_FileMustExist Or ofn_HideReadOnly;
lStructSize := SizeOf(tOpenFileName);
nFilterIndex := 1; {Index into Filter String in lpstrFilter}
nMaxFile := SizeOf(FullFileName);
End;
If GetOpenFileName(OpenFN) Then
StrCopy(aFn, FullFileName)
Else
StrCopy(aFn, '')
End;
Function tInfoWindow.GetPascalFileName (aFn: pChar): pChar;
Var
OpenFN : tOpenFileName;
Filter : array[0..100] of Char;
FName,
FullFileName: array[0..100] Of Char;
Begin
GetPascalFileName:= aFn;
StrCopy(FullFileName, aFn);
FillChar(Filter, SizeOf(Filter), #0); { Set up for double null at end }
StrCopy(Filter, 'Pascal units (*.PAS)');
StrCopy(@Filter[StrLen(Filter)+1], '*.PAS');
FillChar(OpenFN, SizeOf(TOpenFileName), #0);
With OpenFN Do Begin
hInstance := System.hInstance;
hwndOwner := hWindow;
lpstrDefExt := 'PAS';
lpstrTitle := 'Save as Pascal unit';
lpstrFile := FullFileName;
lpstrFilter := Filter;
lpstrFileTitle:= FName;
flags := ofn_HideReadOnly;
lStructSize := SizeOf(tOpenFileName);
nFilterIndex := 1; {Index into Filter String in lpstrFilter}
nMaxFile := SizeOf(FullFileName);
End;
If GetSaveFileName(OpenFN) Then
StrCopy(aFn, FullFileName)
Else
StrCopy(aFn, '')
End;
Function StrForceExtension (Dst, Src, Ext: pChar): pChar;
Var
p: pChar;
Begin
StrForceExtension:= StrCopy(Dst,Src);
p:= StrRScan(Dst, '.');
If Assigned(p) Then
p^:= #0;
StrCat(Dst,'.');
StrCat(Dst,Ext)
End;
Procedure tInfoWindow.cmConvertOne (Var Msg: tMessage);
Var
SrcName, DstName: Array[0..67] Of Char;
Begin
If (StrLen(GetFileName(SrcName))>0)
And (StrLen(GetPascalFileName(StrForceExtension(DstName,SrcName,'Pas')))>0)
And GenerateInfo(SrcName, DstName) Then
MessageBox(hWindow,'Pascal unit generated successfully.','Information', mb_Ok)
End;
Procedure tInfoWindow.cmConvertSpecial (Var Msg: tMessage);
Var
Error: Boolean;
Begin
If GenerateInfo('D:\Win\System\ThreeD.Vbx', 'C:\Wrk\ThreeD.Pas')
And GenerateInfo('D:\Win\System\Spin.Vbx', 'C:\Wrk\Spin.Pas')
And GenerateInfo('D:\Win\System\Grid.Vbx', 'C:\Wrk\Grid.Pas')
And GenerateInfo('D:\Win\System\Gauge.Vbx', 'C:\Wrk\Gauge.Pas')
And GenerateInfo('D:\Win\System\MHTR200.Vbx', 'C:\Wrk\MHTr200.Pas')
And GenerateInfo('D:\Win\System\MListPP.Vbx', 'C:\Wrk\MListPP.Pas')
Then
MessageBox(hWindow,'all units generated successfully.','Information', mb_Ok)
End;
Procedure Error (aMsg: pChar);
Begin
MessageBox(0, aMsg, 'Error', mb_IconExclamation+mb_Ok)
End;
Var
aBuf, BufPtr: pChar;
DstFile: File;
Procedure WriteBuf;
Var
Wr, ToWr: Word;
Begin
ToWr:= StrLen(aBuf);
BlockWrite(DstFile, aBuf[0], ToWr, Wr);
If Wr<ToWr Then Begin
MessageBox(0,'Can''t write to file.'#10'Disk full?','Fatal Error', mb_IconExclamation Or mb_Ok);
Halt(1)
End;
aBuf[0]:= #0;
BufPtr:= aBuf
End;
Procedure CheckBuf;
Begin
If Word(BufPtr)>40000 Then
WriteBuf
End;
Type
pModelInfo = ^tModelInfo;
tModelInfo = Record
usVersion: Word; { VB version used by control }
fl: LongInt; { Bitfield structure }
pctlproc: pointer; { the control proc. }
fsClassStyle: Word; { window class style }
flWndStyle: LongInt; { default window style }
cbCtlExtra: Word; { # bytes alloc'd for HCTL structure }
idBmpPalette: Word; { BITMAP id for tool palette }
npszDefCtlName: Word; { offset of default control name prefix }
npszClassName: Word; { offset of Visual Basic class name }
npszParentClassName: Word; { offset of Parent window class if subclassed }
npproplist: Word; { offset of Property list }
npeventlist: Word; { offset of Event list }
nDefProp: Byte; { index of default property }
nDefEvent: Byte; { index of default event }
nValueProp: byte;
usControlVersion: word
End;
pVbxClass = ^tVbxClass;
tVbxClass = Record
dummy: Array[0..5] Of Byte;
ModelInfo: pModelInfo
End;
pPropInfo = ^tPropInfo;
tPropInfo = Record
npszName : Word;
fl : LongInt;
OffsetData : Byte;
InfoData : Byte;
DataDefault : LongInt;
npszEnumList : Word;
EnumMax : Byte
End;
pDumpControl = ^tDumpControl;
tDumpControl = Object(tVbxControl)
Model: pModelInfo;
VbxBaseName: Array[0..67] Of Char;
Constructor Init (aParent: pInfoWindow; aVbxName, aVbxClass: pChar;
aModel: pModelInfo);
Function GetEventId (Dst: pChar; Index: Integer): pChar;
Function IsValidProp (Index: Integer): Boolean;
Procedure DumpEnums;
Procedure DumpDefaultData;
Procedure DumpPropProc (Definition: Boolean);
Procedure DumpObjectDefinition;
Procedure DumpObjectImplementation;
End;
NumStr = Array[0..30] Of Char;
Function L2Str (Dst: pChar; aLong: LongInt): pChar;
Begin
L2Str:= Dst;
Str(aLong, NumStr(Pointer(Dst)^))
End;
Function HexStr (Dst: pChar; aByte: Byte): pChar;
Const
HC: Array[0..$F] Of Char = '0123456789ABCDEF';
Begin
HexStr:= Dst;
Dst[0]:= HC[aByte Shr 4];
Dst[1]:= HC[aByte And $F];
Dst[2]:= #0
End;
Function Str2Id (Dst, Src: pChar): pChar;
Begin
Str2Id:= Dst;
While Src[0]<>#0 Do Begin
Dst[0]:= Src[0];
Case Src[0] Of
'a'..'z',
'A'..'Z',
'0'..'9',
'_': Inc(Dst)
End;
Inc(Src)
End;
Dst[0]:= #0
End;
Function StrJustName (Dst, Src: pChar): pChar;
Var
p: pChar;
Begin
p:= StrRScan(Src,'\');
If Not Assigned(p) Then
p:= StrRScan(Src,':');
If Not Assigned(p) Then
p:= Src
Else
Inc(p);
StrJustName:= StrCopy(Dst, p)
End;
Function StrPropType(Dst: pChar; aType: Integer): pChar;
Begin
StrPropType:= Dst;
Case aType Of
PType_Long,
PType_XPos, PType_XSize,
PType_YPos, PType_YSize: StrCopy(Dst, 'LongInt');
PType_Color: StrCopy(Dst, 'tColorRef');
PType_CString: StrCopy(Dst, 'hSz');
PType_BString: StrCopy(Dst, 'hLStr');
PType_Picture: StrCopy(Dst, 'hPic');
PType_Short: StrCopy(Dst, 'Integer');
PType_Bool: StrCopy(Dst, 'Bool');
PType_Real: StrCopy(Dst, 'Single');
PType_Enum: StrCopy(Dst, 'Byte');
Else
StrCopy(Dst, '<unknown>')
End;
End;
Function StrPropTypeCast(Dst: pChar; aType: Integer): pChar;
Begin
StrPropTypeCast:= Dst;
Case aType Of
PType_Long,
PType_XPos, PType_XSize,
PType_YPos, PType_YSize: StrCopy(Dst, '');
PType_Color: StrCopy(Dst, 'LongInt');
PType_CString: StrCopy(Dst, '');
PType_BString: StrCopy(Dst, '');
PType_Picture: StrCopy(Dst, 'Integer');
PType_Short: StrCopy(Dst, '');
PType_Bool: StrCopy(Dst, 'Integer');
PType_Real: StrCopy(Dst, '');
PType_Enum: StrCopy(Dst, 'Byte');
Else
StrCopy(Dst, '')
End;
End;
Function StrPropProcName(Dst: pChar; aType: Integer): pChar;
Begin
StrPropProcName:= Dst;
Case aType Of
PType_Long,
PType_XPos, PType_XSize,
PType_YPos, PType_YSize: StrCopy(Dst, '');
PType_Color: StrCopy(Dst, '');
PType_CString: StrCopy(Dst, 'Str');
PType_BString: StrCopy(Dst, 'BStr');
PType_Picture: StrCopy(Dst, 'Int');
PType_Short: StrCopy(Dst, 'Int');
PType_Bool: StrCopy(Dst, 'Int');
PType_Real: StrCopy(Dst, 'Single');
PType_Enum: StrCopy(Dst, 'Byte');
Else
StrCopy(Dst, '<unknown>')
End;
End;
Function StrEventArgType (Dst: pChar; aType: Integer): pChar;
Begin
StrEventArgType:= Dst;
Case aType Of
1: StrCopy(Dst,'Integer');
2: StrCopy(Dst,'LongInt');
3: StrCopy(Dst,'Single');
4: StrCopy(Dst,'Double');
5: StrCopy(Dst,'Double{Curr}');
6: StrCopy(Dst,'hLStr');
7: StrCopy(Dst,'hSz');
Else
StrCopy(Dst, '<unknown>')
End
End;
Function MakeLp (aPointer: Pointer; Index: Word): Pointer;
Inline($58/$5B/$5A); {Pop Ax Bx Dx}
Function VBReadFormFile (hForm: tHandle; Data: Pointer; cb: Word): Word;
Inline($BB/$3C/$00/ $36/$FF/$1E/$20/$00); {Mov Bx,$3C; Call [SS:20]}
Function VBSeekFormFile (hForm: tHandle; Offset: LongInt): LongInt;
Inline($BB/$A0/$00/ $36/$FF/$1E/$20/$00); {Mov Bx,$A0; Call [SS:20]}
Constructor tDumpControl.Init (aParent: pInfoWindow; aVbxName, aVbxClass: pChar;
aModel: pModelInfo);
Begin
Inherited Init (aParent, 0, aVbxName, aVbxClass, Nil, 0, 0, 0, 0, 0, Nil);
Model:= aModel;
StrJustName(VbxBaseName, aVbxName)
End;
Function tDumpControl.GetEventId (Dst: pChar; Index: Integer): pChar;
Begin
GetEventId:= Str2Id(Dst, GetEventName(Index))
End;
Function tDumpControl.IsValidProp (Index: Integer): Boolean;
Var
p: pPropInfo;
Begin
p:= dVbx.VbxGetModelPropInfo(Model, Index);
IsValidProp:= Assigned(p) And (p^.npszName<>0) And (Word(MakeLp(p,p^.npszName)^)<>$0020)
End;
Function StripJunk (Dst, Src: pChar): pChar;
Begin
StripJunk:= Dst;
While Src[0]<>#0 Do Begin
Dst[0]:= Src[0];
Case Src[0] Of
'a'..'z',
'A'..'Z',
'_': Inc(Dst)
End;
Inc(Src)
End;
Dst[0]:= #0
End;
Procedure tDumpControl.DumpEnums;
Var
pType: Integer;
p: pPropInfo;
el: pChar;
i,en: Integer;
aLine: Array[0..200] Of Char;
pref, ty, tmp: array[0..67] Of Char;
Begin
For i:= 0 To GetNumProps-1 Do If IsValidProp(i) Then Begin
p:= dVbx.VbxGetModelPropInfo(Model, i);
pType:= GetPropType(i);
If pType=PType_Enum Then Begin
Str2Id(Ty, GetPropName(i));
If Prefix^.MakePrefix(pref, Ty) Then Begin
StrCat(StrCat(StrCopy(aLine,' en'), Ty),' = (');
el:= MakeLp(p, p^.npszEnumList);
While el[0]<>#0 Do Begin
StrCat(StrCat(aLine, pref), StripJunk(Tmp, el));
el:= StrEnd(el)+1;
If el[0]<>#0 Then StrCat(aLine, ', ');
If (StrLen(aLine)>80) And (el[0]<>#0) Then Begin
BufPtr:= StrEnd(StrCat(StrCat(BufPtr, aLine),#13#10));
FillChar(aLine, StrLen(ty)+8,' ');
aLine[StrLen(ty)+8]:= #0
End;
End;
StrCat(aLine,');'#13#10);
BufPtr:= StrEnd(StrCat(BufPtr, aLine))
End
End
End
End;
Procedure tDumpControl.DumpPropProc (Definition: Boolean);
Const
PropFn: Array[Boolean] Of pChar = ('SetProp','GetProp');
PropArrayFn: Array[Boolean] Of pChar = ('SetArrayProp','GetArrayProp');
Var
i: Integer;
pType: Integer;
Get: Boolean;
Ty,Tc,Pr: Array[0..67] Of Char;
Begin
If Definition Then StrCat(BufPtr,' ');
StrCat(BufPtr, '{-Properties}'#13#10);
For i:= 0 To GetNumProps-1 Do If IsValidProp(i) Then Begin
pType:= GetPropType(i);
If pType In [PType_CString..PType_BString] Then Begin
If pType=PType_Enum Then
Str2Id(StrEnd(StrCopy(Ty,'en')), GetPropName(i))
Else
StrPropType(Ty, pType);
StrPropTypeCast(Tc, pType);
StrPropProcName(Pr, pType);
For Get:= False To True Do Begin
If Definition Then
StrCat(StrCat(BufPtr,' Function '), PropFn[Get])
Else
StrCat(StrCat(StrCat(StrCat(BufPtr,'Function t'),VbxClass),'.'),PropFn[Get]);
StrCat(Str2Id(StrEnd(BufPtr), GetPropName(i)), ' (');
If IsArrayProp(i) Then StrCat(BufPtr, 'Index: Integer; ');
If Get Then StrCat(BufPtr,'Var ');
StrCat(StrCat(StrCat(BufPtr, 'aValue: '),Ty),'): Bool;'#13#10);
If Not Definition Then Begin
StrCat(StrCat(BufPtr,'Begin'#13#10' '),PropFn[Get]);
Str2Id(StrEnd(BufPtr), GetPropName(i));
StrCat(BufPtr,':= ');
If IsArrayProp(i) Then
StrCat(BufPtr, PropArrayFn[Get])
Else
StrCat(BufPtr,PropFn[Get]);
StrCat(BufPtr, Pr);
L2Str(StrEnd(StrCat(BufPtr,'(')), i);
If IsArrayProp(i) Then
StrCat(BufPtr,', Index, ')
Else
StrCat(BufPtr,', ');
If StrLen(Tc)>0 Then
StrCat(StrCat(BufPtr,Tc),'(aValue)')
Else
StrCat(BufPtr, 'aValue');
StrCat(BufPtr, ')'#13#10'End;'#13#10#13#10)
End;
BufPtr:= StrEnd(BufPtr)
End
End;
CheckBuf
End
End;
Procedure tDumpControl.DumpDefaultData;
Var
aFormFile: tHandle;
cl, l: LongInt;
aByte: Byte;
aLine: Array[0..150] Of Char;
Begin
aFormFile:= dVbx.VBXSaveProperties(Ctl);
If aFormFile=0 Then Exit;
l:= dVbx.VBXGetFormFileLength(aFormFile);
If l<1 Then Exit;
VBSeekFormFile(aFormFile, 0);
BufPtr:= StrEnd(StrCat(StrCat(StrCat(BufPtr,'Const'#13#10+
' Data'), VbxClass), ': Array[0..'));
L2Str(BufPtr, l-1);
StrCat(BufPtr,'] Of Byte = ('#13#10);
StrCopy(aLine,' ');
For cl:= 0 To l-1 Do Begin
VBReadFormFile(aFormFile, @aByte, 1);
StrCat(aLine,'$');
HexStr(StrEnd(aLine), aByte);
If cl<l-1 Then StrCat(aLine,',');
If StrLen(aLine)>68 Then Begin
BufPtr:= StrEnd(StrCat(StrCat(BufPtr, aLine),#13#10));
StrCopy(aLine, ' ');
End;
End;
BufPtr:= StrEnd(StrCat(StrCat(BufPtr, aLine),');'#13#10));
CheckBuf;
dVbx.VbxDeleteFormFile(aFormFile)
End;
Procedure tDumpControl.DumpObjectDefinition;
Var
i: Integer;
Tmp: Array[0..67] Of Char;
Begin
StrCat(StrCat(StrCat(BufPtr,'Type'#13#10+
'{-t'), VbxClass), ' }'#13#10);
DumpEnums;
BufPtr:= StrEnd(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(BufPtr,
#13#10+
' p'), VbxClass), ' = ^t'), VbxClass), ';'#13#10' t'), VbxClass),
' = Object(tVbxControl)'#13#10+
' Constructor Init (aParent: pWindowsObject; anId: Integer; Title: pChar;'#13#10+
' x,y,w,h: Integer; Len: LongInt; Data: Pointer);'#13#10));
StrCat(BufPtr, ' {-Events}'#13#10);
For i:= 0 To GetNumEvents-1 Do Begin
BufPtr:= StrEnd(StrCat(StrCat(StrCat(StrCat(StrCat(BufPtr,
' Procedure ev'), GetEventId(Tmp, i)),
' (Var Event: tVbxEvent); Virtual ev_First+'), L2Str(Tmp, i)), ';'#13#10));
CheckBuf
End;
DumpPropProc(True);
BufPtr:= StrEnd(StrCat(BufPtr, ' End;'#13#10));
DumpDefaultData
End;
Procedure tDumpControl.DumpObjectImplementation;
Type
pEventInfo = ^tEventInfo;
tEventInfo = Record
npszName: Word;
cParms,
cwParms: Word;
npParamTypes: Word;
npszParmProf: Word;
fl: LongInt
End;
Var
i: Integer;
Tmp: Array[0..67] Of Char;
p: pEventInfo;
el: pChar;
en: Integer;
pw: ^Word;
Begin
BufPtr:= StrEnd(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(BufPtr,
'{- '), VbxClass), ' }'#13#10+
'Constructor t'), VbxClass), '.Init (aParent: pWindowsObject; anId: Integer; Title: pChar;'#13#10+
' x,y,w,h: Integer; Len: LongInt; Data: Pointer);'#13#10+
'Begin'#13#10+
' Inherited Init(aParent, anId, '''), VbxBaseName), ''', '''), VbxClass),
''', Title, x, y, w, h, '#13#10+
' SizeOf(Data'), VbxClass),'), @Data'), VbxClass),');'#13#10+
'End;'#13#10+
#13#10));
For i:= 0 To GetNumEvents-1 Do Begin
BufPtr:= StrEnd(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(BufPtr,
'Procedure t'), VbxClass), '.ev'), GetEventId(Tmp, i)), ' (Var Event: tVbxEvent);'#13#10+
'Begin'#13#10+
' {$IfDef Debug} WriteLn(''[t'), VbxClass), '.ev'), GetEventId(Tmp, i)), ']''); {$EndIf}'#13#10));
p:= dVbx.VbxGetModelEventInfo(Model, i);
If Assigned(p) And (p^.cParms<>0) Then Begin
StrCat(BufPtr,'{'); l2str(StrEnd(BufPtr),p^.cParms);
StrCat(BufPtr,' params: ');
pw:= MakeLp(p,p^.npParamTypes);
For en:= 1 To p^.cParms Do Begin
StrEventArgType(StrEnd(BufPtr), pw^);
Inc(pw);
StrCat(BufPtr,' ')
End;
StrCat(BufPtr,#13#10' descr= ');
StrCat(BufPtr, MakeLp(p, p^.npszParmProf));
BufPtr:= StrEnd(StrCat(BufPtr,'}'#13#10))
End;
BufPtr:= StrEnd(StrCat(BufPtr, 'End;'#13#10#13#10));
CheckBuf
End;
DumpPropProc(False)
End;
Function tInfoWindow.GenerateInfo (aVBXName, aPascalName: pChar): Boolean;
Var
ci: pVbxClass;
p: pChar;
Ctl: pDumpControl;
ModName: Array[0..67] Of Char;
Begin
GenerateInfo:= False;
aBuf:= MemAlloc(64000);
If Not Assigned(aBuf) Then Begin Error('Can''t allocate buffer'); Exit End;
dVbx.Done; {we need this because dVbx is already initialized!}
dVbx.Init(True);
If Not dVbx.LibLink Or Not dVbx.VbxLoadVbx(aVBXName) Then Begin
Error('Can''t load VBX file');
Exit
End;
Prefix:= New(pPrefixCollection, Init(100, 5));
aBuf[0]:= #0; BufPtr:= aBuf;
{$i-}
Assign(DstFile, aPascalName); ReWrite(DstFile, 1);
If IoResult<>0 Then Begin Error('Can''t create Pascal file'); Exit End;
StrJustName(ModName, aPascalName);
p:= StrScan(ModName, '.'); If Assigned(p) Then p^:= #0;
StrCat(StrCat(StrCat(aBuf, 'Unit '), ModName),';'#13#10+
'{this file was automatically generated by VbxInfo.'#13#10+
' VbxInfo is (c) 1994 Peter Sawatzki}'#13#10+
'Interface'#13#10+
'Uses'#13#10+
' WinTypes,'#13#10+
' oWindows,'#13#10+
' Vbx;'#13#10);
ci:= dVBX.VbxGetFirstClass;
While Assigned(ci) Do With ci^, ModelInfo^ Do Begin
Ctl:= New(pDumpControl, Init(@Self, aVbxName, MakeLp(ModelInfo, npszClassName), ModelInfo));
If Assigned(Ctl) Then Begin
With Ctl^ Do If Create Then Begin
DumpObjectDefinition;
Destroy
End;
Dispose(Ctl, Done)
End;
ci:= dVbx.VbxGetNextClass(ci);
CheckBuf
End;
StrCat(aBuf, #13#10'Implementation'#13#10);
ci:= dVBX.VbxGetFirstClass;
While Assigned(ci) Do With ci^, ModelInfo^ Do Begin
Ctl:= New(pDumpControl, Init(@Self, aVbxName, MakeLp(ModelInfo, npszClassName), ModelInfo));
If Assigned(Ctl) Then Begin
With Ctl^ Do If Create Then Begin
DumpObjectImplementation;
Destroy
End;
Dispose(Ctl, Done)
End;
ci:= dVbx.VbxGetNextClass(ci);
CheckBuf
End;
StrCat(aBuf, 'End.');
WriteBuf;
Close(DstFile); If IoResult<>0 Then Begin Error('Can''t close file'); Exit End;
Dispose(Prefix, Done);
FreeMem(aBuf, 64000);
GenerateInfo:= True
End;
{-------------------- the Application part }
Const
ProgName = 'VbxInfo';
Type
tProgApp = Object(tApplication)
Procedure InitMainWindow; Virtual;
End;
Procedure tProgApp.InitMainWindow;
Begin
MainWindow:= New(pInfoWindow, Init(Nil, ProgName))
End;
Var
App: tProgApp;
Begin
RegisterVBX(VBXvalidation);
With App Do Begin
Init(ProgName);
Run;
Done
End
End.